home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / ADA / GNAT / !gcc / adainc / 2 / adb / a-ststio < prev    next >
Text File  |  1996-02-12  |  12KB  |  428 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                A D A . S T R E A M S . S T R E A M _ I O                 --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.18 $                             --
  10. --                                                                          --
  11. --   Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc.  --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22. -- MA 02111-1307, USA.                                                      --
  23. --                                                                          --
  24. -- As a special exception,  if other files  instantiate  generics from this --
  25. -- unit, or you link  this unit with other files  to produce an executable, --
  26. -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27. -- covered  by the  GNU  General  Public  License.  This exception does not --
  28. -- however invalidate  any other reasons why  the executable file  might be --
  29. -- covered by the  GNU Public License.                                      --
  30. --                                                                          --
  31. -- GNAT was originally developed  by the GNAT team at  New York University. --
  32. -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33. --                                                                          --
  34. ------------------------------------------------------------------------------
  35.  
  36. with Interfaces.C_Streams;      use Interfaces.C_Streams;
  37. with System;                    use System;
  38. with System.File_IO;
  39. with System.Tasking_Soft_Links;
  40. with Unchecked_Conversion;
  41. with Unchecked_Deallocation;
  42.  
  43. package body Ada.Streams.Stream_IO is
  44.  
  45.    package FIO renames System.File_IO;
  46.  
  47.    subtype AP is FCB.AFCB_Ptr;
  48.  
  49.    function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode);
  50.    function To_SIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode);
  51.    use type FCB.File_Mode;
  52.    use type FCB.Shared_Status_Type;
  53.  
  54.    -----------------------
  55.    -- Local Subprograms --
  56.    -----------------------
  57.  
  58.    procedure Set_Position (File : in File_Type);
  59.    --  Sets file position pointer according to value of current index
  60.  
  61.    -------------------
  62.    -- AFCB_Allocate --
  63.    -------------------
  64.  
  65.    function AFCB_Allocate (Control_Block : Stream_AFCB) return FCB.AFCB_Ptr is
  66.    begin
  67.       return new Stream_AFCB;
  68.    end AFCB_Allocate;
  69.  
  70.    ----------------
  71.    -- AFCB_Close --
  72.    ----------------
  73.  
  74.    --  No special processing required for closing Stream_IO file
  75.  
  76.    procedure AFCB_Close (File : access Stream_AFCB) is
  77.    begin
  78.       null;
  79.    end AFCB_Close;
  80.  
  81.    ---------------
  82.    -- AFCB_Free --
  83.    ---------------
  84.  
  85.    procedure AFCB_Free (File : access Stream_AFCB) is
  86.       type FCB_Ptr is access all Stream_AFCB;
  87.       FT : FCB_Ptr := File;
  88.  
  89.       procedure Free is new Unchecked_Deallocation (Stream_AFCB, FCB_Ptr);
  90.  
  91.    begin
  92.       Free (FT);
  93.    end AFCB_Free;
  94.  
  95.    -----------
  96.    -- Close --
  97.    -----------
  98.  
  99.    procedure Close (File : in out File_Type) is
  100.    begin
  101.       FIO.Close (AP (File));
  102.    end Close;
  103.  
  104.    ------------
  105.    -- Create --
  106.    ------------
  107.  
  108.    procedure Create
  109.      (File : in out File_Type;
  110.       Mode : in File_Mode := Out_File;
  111.       Name : in String := "";
  112.       Form : in String := "")
  113.    is
  114.       File_Control_Block : Stream_AFCB;
  115.  
  116.    begin
  117.       FIO.Open (File_Ptr  => AP (File),
  118.                 Dummy_FCB => File_Control_Block,
  119.                 Mode      => To_FCB (Mode),
  120.                 Name      => Name,
  121.                 Form      => Form,
  122.                 Amethod   => 'S',
  123.                 Creat     => True,
  124.                 Text      => False);
  125.       File.Last_Op := Op_Write;
  126.    end Create;
  127.  
  128.    ------------
  129.    -- Delete --
  130.    ------------
  131.  
  132.    procedure Delete (File : in out File_Type) is
  133.    begin
  134.       FIO.Delete (AP (File));
  135.    end Delete;
  136.  
  137.    -----------------
  138.    -- End_Of_File --
  139.    -----------------
  140.  
  141.    function End_Of_File (File : in File_Type) return Boolean is
  142.    begin
  143.       FIO.Check_Read_Status (AP (File));
  144.       return Count (File.Index) > Size (File);
  145.    end End_Of_File;
  146.  
  147.    -----------
  148.    -- Flush --
  149.    -----------
  150.  
  151.    procedure Flush (File : in out File_Type) is
  152.    begin
  153.       FIO.Flush (AP (File));
  154.    end Flush;
  155.  
  156.    ----------
  157.    -- Form --
  158.    ----------
  159.  
  160.    function Form (File : in File_Type) return String is
  161.    begin
  162.       return FIO.Form (AP (File));
  163.    end Form;
  164.  
  165.    -----------
  166.    -- Index --
  167.    -----------
  168.  
  169.    function Index (File : in File_Type) return Positive_Count is
  170.    begin
  171.       FIO.Check_File_Open (AP (File));
  172.       return Count (File.Index);
  173.    end Index;
  174.  
  175.    -------------
  176.    -- Is_Open --
  177.    -------------
  178.  
  179.    function Is_Open (File : in File_Type) return Boolean is
  180.    begin
  181.       return FIO.Is_Open (AP (File));
  182.    end Is_Open;
  183.  
  184.    ----------
  185.    -- Mode --
  186.    ----------
  187.  
  188.    function Mode (File : in File_Type) return File_Mode is
  189.    begin
  190.       return To_SIO (FIO.Mode (AP (File)));
  191.    end Mode;
  192.  
  193.    ----------
  194.    -- Name --
  195.    ----------
  196.  
  197.    function Name (File : in File_Type) return String is
  198.    begin
  199.       return FIO.Name (AP (File));
  200.    end Name;
  201.  
  202.    ----------
  203.    -- Open --
  204.    ----------
  205.  
  206.    procedure Open
  207.      (File : in out File_Type;
  208.       Mode : in File_Mode;
  209.       Name : in String;
  210.       Form : in String := "")
  211.    is
  212.       File_Control_Block : Stream_AFCB;
  213.  
  214.    begin
  215.       FIO.Open (File_Ptr  => AP (File),
  216.                 Dummy_FCB => File_Control_Block,
  217.                 Mode      => To_FCB (Mode),
  218.                 Name      => Name,
  219.                 Form      => Form,
  220.                 Amethod   => 'S',
  221.                 Creat     => False,
  222.                 Text      => False);
  223.       File.Last_Op := Op_Read;
  224.    end Open;
  225.  
  226.    ----------
  227.    -- Read --
  228.    ----------
  229.  
  230.    procedure Read
  231.      (File : in File_Type;
  232.       Item : out Stream_Element_Array;
  233.       Last : out Stream_Element_Offset;
  234.       From : in Positive_Count)
  235.    is
  236.    begin
  237.       Set_Index (File, From);
  238.       Read (File, Item, Last);
  239.    end Read;
  240.  
  241.    procedure Read
  242.      (File : in File_Type;
  243.       Item : out Stream_Element_Array;
  244.       Last : out Stream_Element_Offset)
  245.    is
  246.       Nread : size_t;
  247.  
  248.    begin
  249.       FIO.Check_Read_Status (AP (File));
  250.  
  251.       --  If last operation was not a read, or if in file sharing mode,
  252.       --  then reset the physical pointer of the file to match the index
  253.       --  We lock out task access over the two operations in this case.
  254.  
  255.       if File.Last_Op /= Op_Read
  256.         or else File.Shared_Status = FCB.Yes
  257.       then
  258.          if End_Of_File (File) then
  259.             raise End_Error;
  260.          end if;
  261.  
  262.          System.Tasking_Soft_Links.Lock_Task;
  263.          Set_Position (File);
  264.          FIO.Read_Buf (AP (File), Item'Address, Item'Length, Nread);
  265.          System.Tasking_Soft_Links.Unlock_Task;
  266.  
  267.       else
  268.          FIO.Read_Buf (AP (File), Item'Address, Item'Length, Nread);
  269.       end if;
  270.  
  271.       File.Index := File.Index + Count (Nread);
  272.       Last := Item'First + Stream_Element_Offset (Nread) - 1;
  273.       File.Last_Op := Op_Read;
  274.    end Read;
  275.  
  276.    --  This version of Read is the primitive operation on the underlying
  277.    --  Stream type, used when a Stream_IO file is treated as a Stream
  278.  
  279.    procedure Read
  280.      (File : in out Stream_AFCB;
  281.       Item : out Ada.Streams.Stream_Element_Array;
  282.       Last : out Ada.Streams.Stream_Element_Offset)
  283.    is
  284.    begin
  285.       Read (File'Unchecked_Access, Item, Last);
  286.    end Read;
  287.  
  288.    -----------
  289.    -- Reset --
  290.    -----------
  291.  
  292.    procedure Reset (File : in out File_Type; Mode : in File_Mode) is
  293.    begin
  294.       FIO.Reset (AP (File), To_FCB (Mode));
  295.       File.Index := 1;
  296.       File.Last_Op := Op_Read;
  297.    end Reset;
  298.  
  299.    procedure Reset (File : in out File_Type) is
  300.    begin
  301.       FIO.Reset (AP (File));
  302.       File.Index := 1;
  303.       File.Last_Op := Op_Read;
  304.    end Reset;
  305.  
  306.    ---------------
  307.    -- Set_Index --
  308.    ---------------
  309.  
  310.    procedure Set_Index (File : in File_Type; To : in Positive_Count) is
  311.    begin
  312.       FIO.Check_File_Open (AP (File));
  313.       File.Index := Count (To);
  314.       File.Last_Op := Op_Other;
  315.    end Set_Index;
  316.  
  317.    --------------
  318.    -- Set_Mode --
  319.    --------------
  320.  
  321.    procedure Set_Mode (File : in out File_Type; Mode : in File_Mode) is
  322.    begin
  323.       --  If we are switching from read to write, or vice versa, and
  324.       --  we are not already open in update mode, then reopen in update
  325.       --  mode now. Note that we can use Inout_File as the mode for the
  326.       --  call since File_IO handles all modes for all file types.
  327.  
  328.       if ((File.Mode = FCB.In_File) /= (Mode = In_File))
  329.         and then File.Update_Mode
  330.       then
  331.          FIO.Reset (AP (File), FCB.Inout_File);
  332.       end if;
  333.  
  334.       --  Set required mode and position to end of file if append mode
  335.  
  336.       File.Mode := To_FCB (Mode);
  337.       FIO.Append_Set (AP (File));
  338.       File.Index := Count (ftell (File.Stream)) + 1;
  339.       File.Last_Op := Op_Other;
  340.    end Set_Mode;
  341.  
  342.    ------------------
  343.    -- Set_Position --
  344.    ------------------
  345.  
  346.    procedure Set_Position (File : in File_Type) is
  347.    begin
  348.       if fseek (File.Stream, long (File.Index) - 1, SEEK_SET) /= 0 then
  349.          raise Use_Error;
  350.       end if;
  351.    end Set_Position;
  352.  
  353.    ----------
  354.    -- Size --
  355.    ----------
  356.  
  357.    function Size (File : in File_Type) return Count is
  358.    begin
  359.       FIO.Check_File_Open (AP (File));
  360.       File.Last_Op := Op_Other;
  361.  
  362.       if fseek (File.Stream, 0, SEEK_END) /= 0 then
  363.          raise Device_Error;
  364.       end if;
  365.  
  366.       return Positive_Count (ftell (File.Stream));
  367.    end Size;
  368.  
  369.    ------------
  370.    -- Stream --
  371.    ------------
  372.  
  373.    function Stream (File : in File_Type) return Stream_Access is
  374.    begin
  375.       FIO.Check_File_Open (AP (File));
  376.       return Stream_Access (File);
  377.    end Stream;
  378.  
  379.    -----------
  380.    -- Write --
  381.    -----------
  382.  
  383.    procedure Write
  384.      (File : in File_Type;
  385.       Item : in Stream_Element_Array;
  386.       To   : in Positive_Count)
  387.    is
  388.    begin
  389.       Set_Index (File, To);
  390.       Write (File, Item);
  391.    end Write;
  392.  
  393.    procedure Write (File : in File_Type; Item : in Stream_Element_Array) is
  394.    begin
  395.       FIO.Check_Write_Status (AP (File));
  396.  
  397.       --  If last operation was not a write, or if in file sharing mode,
  398.       --  then reset the physical pointer of the file to match the index
  399.       --  We lock out task access over the two operations in this case.
  400.  
  401.       if File.Last_Op /= Op_Write
  402.         or else File.Shared_Status = FCB.Yes
  403.       then
  404.          System.Tasking_Soft_Links.Lock_Task;
  405.          Set_Position (File);
  406.          FIO.Write_Buf (AP (File), Item'Address, Item'Length);
  407.          System.Tasking_Soft_Links.Unlock_Task;
  408.       else
  409.          FIO.Write_Buf (AP (File), Item'Address, Item'Length);
  410.       end if;
  411.  
  412.       File.Index := File.Index + Item'Length;
  413.       File.Last_Op := Op_Write;
  414.    end Write;
  415.  
  416.    --  This version of Write is the primitive operation on the underlying
  417.    --  Stream type, used when a Stream_IO file is treated as a Stream
  418.  
  419.    procedure Write
  420.      (File : in out Stream_AFCB;
  421.       Item : in Ada.Streams.Stream_Element_Array)
  422.    is
  423.    begin
  424.       Write (File'Unchecked_Access, Item);
  425.    end Write;
  426.  
  427. end Ada.Streams.Stream_IO;
  428.